;;; Ypsilon Scheme System
;;; Copyright (c) 2004-2008 Y.FUJITA, LittleWing Company Limited.
;;; See license.txt for terms and conditions of use.

(define raise
  (lambda (c)
    (cond ((current-exception-handler)
           => (lambda (proc)
                (proc c)
                (proc (condition (make-non-continuable-violation)
                                 (make-who-condition 'raise)
                                 (make-message-condition "returned from non-continuable exception")
                                 (make-irritants-condition (list c))))))
          (else
           (current-exception-handler #f)
           (scheme-error "error in raise: unhandled exception has occurred~%~%irritants:~%~a" (describe-condition #f c))))))

(define raise-continuable
  (lambda (c)
    (cond ((current-exception-handler)
           => (lambda (proc) (proc c)))
          (else
           (current-exception-handler #f)
           (scheme-error "error in raise-continuable: unhandled exception has occurred~%~%irritants:~%~a" (describe-condition #f c))))))

(define with-exception-handler
  (lambda (new thunk)
    (let ((parent (current-exception-handler)))
      (parameterize
          ((current-exception-handler
            (lambda (condition)
              (parameterize ((current-exception-handler parent))
                (new condition)))))
        (thunk)))))

(define assertion-violation
  (lambda (who message . irritants)
    (raise
     (apply condition
            (filter values
                    (list (make-assertion-violation)
                          (and who (make-who-condition who))
                          (make-message-condition message)
                          (and (pair? irritants) (make-irritants-condition irritants))))))))

(define undefined-violation
  (lambda (who . message)
    (raise
     (apply condition
            (filter values
                    (list (make-undefined-violation)
                          (and who (make-who-condition who))
                          (and (pair? message) (make-message-condition (car message)))))))))

(define lexical-violation
  (lambda (who . message)
    (raise
     (apply condition
            (filter values
                    (list (make-lexical-violation)
                          (and who (make-who-condition who))
                          (and (pair? message) (make-message-condition (car message)))))))))

(define syntax-violation
  (lambda (who message form . subform)
    (raise
     (apply condition
            (filter values
                    (list (make-syntax-violation form (and (pair? subform) (car subform)))
                          (and who (make-who-condition who))
                          (make-message-condition message)))))))

(define error
  (lambda (who message . irritants)
    (raise
     (apply condition
            (filter values
                    (list (make-error)
                          (and who (make-who-condition who))
                          (make-message-condition message)
                          (and (pair? irritants) (make-irritants-condition irritants))))))))

(define implementation-restriction-violation
  (lambda (who message . irritants)
    (raise
     (apply condition
            (filter values
                    (list (make-implementation-restriction-violation)
                          (and who (make-who-condition who))
                          (make-message-condition message)
                          (and (pair? irritants) (make-irritants-condition irritants))))))))

(define undefined/syntax-violation
  (lambda (who message form . subform)
    (raise
     (apply condition
            (filter values
                    (list (make-syntax-violation form (and (pair? subform) (car subform)))
                          (make-undefined-violation)
                          (and who (make-who-condition who))
                          (make-message-condition message)))))))

(define scheme-error
  (lambda args
    (format #t "~!")
    (let ((port (current-error-port)) (proc (current-exception-handler)))
      (cond (proc (raise (apply format args)))
            (else
             (format port "~&~%")
             (apply format port args)
             (format port "~%")
             (display-backtrace)
             (format port "~%[exit]~%")
             (exit #f))))))

(define raise-i/o-filename-error
  (lambda (who message filename . irritants)
    (raise
     (apply condition
            (filter values
                    (list (make-i/o-filename-error filename)
                          (and who (make-who-condition who))
                          (make-message-condition message)
                          (and (pair? irritants) (make-irritants-condition irritants))))))))

(define raise-i/o-error
  (lambda (who message . irritants)
    (raise
     (apply condition
            (filter values
                    (list (make-i/o-error)
                          (and who (make-who-condition who))
                          (make-message-condition message)
                          (and (pair? irritants) (make-irritants-condition irritants))))))))


(define raise-misc-i/o-error-with-port
  (lambda (constructor who message port . options)
    (raise
     (apply condition
            (filter values
                    (list (apply constructor options)
                          (and who (make-who-condition who))
                          (make-message-condition message)
                          (and port (make-i/o-port-error port))
                          (make-irritants-condition (cons* port options))))))))

(define raise-misc-i/o-error
  (lambda (constructor who message . options)
    (raise
     (apply condition
            (filter values
                    (list (apply constructor options)
                          (and who (make-who-condition who))
                          (make-message-condition message)
                          (and (pair? options)
                               (make-irritants-condition options))))))))

(define raise-i/o-read-error
  (lambda (who message port)
    (raise-misc-i/o-error-with-port make-i/o-read-error who message port)))

(define raise-i/o-write-error
  (lambda (who message port)
    (raise-misc-i/o-error-with-port make-i/o-write-error who message port)))

(define raise-i/o-file-protection-error
  (lambda (who message filename)
    (raise-misc-i/o-error make-i/o-file-protection-error who message filename)))

(define raise-i/o-file-is-read-only-error
  (lambda (who message port)
    (raise-misc-i/o-error-with-port make-i/o-file-is-read-only-error who message port)))

(define raise-i/o-file-already-exists-error
  (lambda (who message filename)
    (raise-misc-i/o-error make-i/o-file-already-exists-error who message filename)))

(define raise-i/o-file-does-not-exist-error
  (lambda (who message filename)
    (raise-misc-i/o-error make-i/o-file-does-not-exist-error who message filename)))

(define raise-i/o-invalid-position-error
  (lambda (who message port position)
    (raise-misc-i/o-error-with-port make-i/o-invalid-position-error who message port position)))

(define raise-i/o-decoding-error
  (lambda (who message port)
    (raise-misc-i/o-error make-i/o-decoding-error who message port)))

(define raise-i/o-encoding-error
  (lambda (who message port char)
    (raise-misc-i/o-error make-i/o-encoding-error who message port char)))
